home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / guile-ii.src / guile-ii / guile-src / slib / withfile.scm < prev    next >
Encoding:
Text File  |  1994-05-23  |  2.7 KB  |  83 lines
  1. ; "withfile.scm", with-input-from-file and with-output-to-file for Scheme
  2. ; Copyright (c) 1992, 1993 Aubrey Jaffer
  3. ;;
  4. ;Permission to copy this software, to redistribute it, and to use it
  5. ;for any purpose is granted, subject to the following restrictions and
  6. ;understandings.
  7. ;
  8. ;1.  Any copy made of this software must include this copyright notice
  9. ;in full.
  10. ;
  11. ;2.  I have made no warrantee or representation that the operation of
  12. ;this software will be error-free, and I am under no obligation to
  13. ;provide any services, by way of maintenance, update, or otherwise.
  14. ;
  15. ;3.  In conjunction with products arising from the use of this
  16. ;material, there shall be no use of my name in any advertising,
  17. ;promotional, or sales literature without prior written consent in
  18. ;each case.
  19.  
  20. (require 'dynamic-wind)
  21.  
  22. (define withfile:current-input (current-input-port))
  23. (define withfile:current-output (current-output-port))
  24.  
  25. (define (current-input-port) withfile:current-input)
  26. (define (current-output-port) withfile:current-output)
  27.  
  28. (define (with-input-from-file file thunk)
  29.   (define oport withfile:current-input)
  30.   (define port (open-input-file file))
  31.   (dynamic-wind (lambda () (set! oport withfile:current-input)
  32.                (set! withfile:current-input port))
  33.         (lambda() (let ((ans (thunk))) (close-input-port port) ans))
  34.         (lambda() (set! withfile:current-input oport))))
  35.  
  36. (define (with-output-from-file file thunk)
  37.   (define oport withfile:current-output)
  38.   (define port (open-output-file file))
  39.   (dynamic-wind (lambda() (set! oport withfile:current-output)
  40.                   (set! withfile:current-output port))
  41.         (lambda() (let ((ans (thunk))) (close-output-port port) ans))
  42.         (lambda() (set! withfile:current-output oport))))
  43.  
  44. (define peek-char
  45.   (let ((peek-char peek-char))
  46.     (lambda opt
  47.       (peek-char (if (null? opt) withfile:current-input (car opt))))))
  48.  
  49. (define read-char
  50.   (let ((read-char read-char))
  51.     (lambda opt
  52.       (read-char (if (null? opt) withfile:current-input (car opt))))))
  53.  
  54. (define read
  55.   (let ((read read))
  56.     (lambda opt
  57.       (read (if (null? opt) withfile:current-input (car opt))))))
  58.  
  59. (define write-char
  60.   (let ((write-char write-char))
  61.     (lambda (obj . opt)
  62.       (write-char obj (if (null? opt) withfile:current-output (car opt))))))
  63.  
  64. (define write
  65.   (let ((write write))
  66.     (lambda (obj . opt)
  67.       (write obj (if (null? opt) withfile:current-output (car opt))))))
  68.  
  69. (define display
  70.   (let ((display display))
  71.     (lambda (obj . opt)
  72.       (display obj (if (null? opt) withfile:current-output (car opt))))))
  73.  
  74. (define newline
  75.   (let ((newline newline))
  76.     (lambda opt
  77.       (newline (if (null? opt) withfile:current-output (car opt))))))
  78.  
  79. (define force-output
  80.   (let ((force-output force-output))
  81.     (lambda opt
  82.       (force-output (if (null? opt) withfile:current-output (car opt))))))
  83.